home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / mailcrypt / mc-remail.el.z / mc-remail.el
Encoding:
Text File  |  1998-05-21  |  28.5 KB  |  863 lines
  1. ;; mc-remail.el --- Remailer support for Mailcrypt
  2.  
  3. ;; Copyright (C) 1995 Patrick LoPresti <patl@lcs.mit.edu>
  4.  
  5. ;;{{{ Licensing
  6.  
  7. ;; This file is intended to be used with GNU Emacs.
  8.  
  9. ;; This program is free software; you can redistribute it and/or modify
  10. ;; it under the terms of the GNU General Public License as published by
  11. ;; the Free Software Foundation; either version 2, or (at your option)
  12. ;; any later version.
  13.  
  14. ;; This program is distributed in the hope that it will be useful,
  15. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17. ;; GNU General Public License for more details.
  18.  
  19. ;; You should have received a copy of the GNU General Public License
  20. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  21. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  22.  
  23. ;;}}}
  24. ;;{{{ Load required packages
  25.  
  26. (require 'mail-utils)
  27. (require 'sendmail)
  28. (require 'mailcrypt)
  29.  
  30. (eval-and-compile
  31.   (if (not mc-xemacs-p)
  32.       (progn
  33.     (autoload 'mc-cleanup-recipient-headers "mc-toplev")
  34.     (autoload 'mc-encrypt-message "mc-toplev"))))
  35.  
  36. (eval-and-compile
  37.   (condition-case nil (require 'mailalias) (error nil)))
  38.  
  39. ;;}}}
  40. ;;{{{ Functions dealing with remailer structures
  41.  
  42. (defsubst mc-remailer-create (addr id props pre-encr post-encr)
  43.   "Create a remailer structure.
  44.  
  45. ADDR is the remailer's Email address, a string.
  46.  
  47. ID is the remailer's public key ID (a string) or nil if the same as
  48. ADDR.
  49.  
  50. PROPS is a list of properties, as strings.
  51.  
  52. PRE-ENCR is a list of pre-encryption functions.  Its elements will be
  53. called with the remailer structure itself as argument.
  54.  
  55. POST-ENCR is similar, but for post-encryption functions."
  56. (list 'remailer addr id props pre-encr post-encr))
  57.  
  58. (defsubst mc-remailerp (remailer)
  59.   "Test whether REMAILER is a valid remailer struct."
  60.   (and (listp remailer) (eq 'remailer (car-safe remailer))))
  61.  
  62. (defsubst mc-remailer-address (remailer)
  63.   "Return the Email address of REMAILER."
  64.   (nth 1 remailer))
  65.  
  66. (defsubst mc-remailer-userid (remailer)
  67.   "Return the userid with which to look up the public key for REMAILER."
  68.   (or (nth 2 remailer)
  69.       (mc-strip-address (mc-remailer-address remailer))))
  70.  
  71. (defsubst mc-remailer-properties (remailer)
  72.   "Return the property list for REMAILER"
  73.   (nth 3 remailer))
  74.  
  75. (defsubst mc-remailer-pre-encrypt-hooks (remailer)
  76.   "Return the list of pre-encryption hooks for REMAILER."
  77.   (nth 4 remailer))
  78.  
  79. (defsubst mc-remailer-post-encrypt-hooks (remailer)
  80.   "Return the list of post-encryption hooks for REMAILER."
  81.   (nth 5 remailer))
  82.  
  83. (defun mc-remailer-remove-property (remailer prop)
  84.   (let ((props (append (mc-remailer-properties remailer) nil)))
  85.     (setq props (delete prop props))
  86.     (mc-remailer-create
  87.      (mc-remailer-address remailer)
  88.      (mc-remailer-userid remailer)
  89.      props
  90.      (mc-remailer-pre-encrypt-hooks remailer)
  91.      (mc-remailer-post-encrypt-hooks remailer))))
  92.  
  93. ;;}}}
  94. ;;{{{ User variables
  95.  
  96. (defvar mc-response-block-included-headers
  97.   '("From" "To" "Newsgroups")
  98.   "List of header fields to include in response blocks.
  99.  
  100. These will be copied into the deepest layer of the response block to
  101. help you identify it when it is used to Email you.")
  102.  
  103.  
  104. (defvar mc-remailer-tag "(*REMAILER*)"
  105.   "A string which marks an Email address as belonging to a remailer.")
  106.  
  107. (defvar mc-levien-file-name "~/.remailers"
  108.   "The file containing a Levien format list of remailers.
  109.  
  110. The file is read by `mc-read-levien-file' and `mc-reread-levien-file'.
  111.  
  112. The file should include lines of the following form (other lines
  113. are ignored):
  114.  
  115. $remailer{\"NAME\"} = \"<EMAIL ADDRESS> PROPERTIES\";
  116.  
  117. PROPERTIES is a space-separated set of strings.
  118.  
  119. This format is named after Raphael Levien, who maintains a list of
  120. active remailers.  Do \"finger remailer-list@kiwi.cs.berkeley.edu\"
  121. for the latest copy of his list.")
  122.  
  123. (defvar mc-remailer-user-chains nil
  124.   "An alist of remailer chains defined by the user.
  125.  
  126. Format is
  127.  
  128. ((NAME . REMAILER-LIST)
  129.  (NAME . REMAILER-LIST)
  130.  ...)
  131.  
  132. NAME must be a string.
  133.  
  134. REMAILER-LIST may be an arbitrary sequence, not just a list.  Its
  135. elements may be any of the following:
  136.  
  137. 1) A remailer structure created by `mc-remailer-create'.  This is
  138.    the base case.
  139.  
  140. 2) A string naming another remailer chain to be spliced in
  141.    at this point.
  142.  
  143. 3) A positive integer N representing a chain to be spliced in at this
  144.    point and consisting of a random permutation of the top N remailers
  145.    as ordered in the file `mc-levien-file-name'.
  146.  
  147. 4) An arbitrary Lisp form to be evaluated, which should
  148.    return another REMAILER-LIST to be recursively processed and
  149.    spliced in at this point.
  150.  
  151. The complete alist of chains is given by the union of the two lists
  152. `mc-remailer-internal-chains' and `mc-remailer-user-chains'.")
  153.  
  154. (defvar mc-remailer-internal-chains nil
  155.   "List of \"internal\" remailer chains.
  156.  
  157. This variable is normally generated automatically from a human-readable
  158. list of remailers; see, for example, the function `mc-reread-levien-file'.
  159.  
  160. To define your own chains, you probably want to use the variable
  161. `mc-remailer-user-chains'.  See that variable's documentation for
  162. format information.")
  163.  
  164. (defvar mc-remailer-internal-ranking nil
  165.   "Ordered list of remailers, most reliable first.
  166.  
  167. This variable is normally generated automatically from a human-readable
  168. list of remailers; see, for example, the function `mc-reread-levien-file'.")
  169.  
  170. (defvar mc-remailer-user-response-block
  171.   (function
  172.    (lambda (addr lines block)
  173.      (concat
  174.       ";;;\n"
  175.       (format
  176.        "To reply to this message, take the following %d-line block, remove\n"
  177.        lines)
  178.       "leading \"- \" constructs (if any), and place it at the top of a\n"
  179.       (format "message to %s :\n" addr)
  180.       block)))
  181.   "A function called to generate response block text.
  182.  
  183. Value should be a function taking three arguments (ADDR LINES BLOCK).
  184. ADDR is the address to which the response should be sent.
  185. LINES is the number of lines in the encrypted response block.
  186. BLOCK is the response block itself.
  187. Function should return a string to be inserted into the buffer
  188. by mc-remailer-insert-response-block.")
  189.  
  190. (defvar mc-remailer-pseudonyms nil
  191.   "*A list of your pseudonyms.
  192.  
  193. This is a list of strings.  Completion against it will be available
  194. when you are prompted for your pseudonym.")
  195.  
  196. (defvar mc-remailer-preserved-headers
  197.   '("References" "Followup-to" "In-reply-to")
  198.   "*Header fields which are preserved as hashmark headers when rewriting.
  199.  
  200. This is a list of strings naming the preserved headers.  Note that
  201. \"Subject\", \"Newsgroups\", and \"To\" are handled specially and
  202. should not be included in this list.")
  203.  
  204. ;;}}}
  205. ;;{{{ Handling Levien format remailer lists
  206.  
  207. (defun mc-parse-levien-buffer ()
  208.   ;; Parse a buffer in Levien format.
  209.   (goto-char (point-min))
  210.   (let (chains remailer remailer-name ranking)
  211.     (while
  212.     (re-search-forward
  213.      "^\\$remailer{\"\\(.+\\)\"}[ \t]*=[ \t]*\"\\(.*\\)\";"
  214.      nil t)
  215.       (let ((name (buffer-substring-no-properties
  216.            (match-beginning 1) (match-end 1)))
  217.         property-list address
  218.         (value-start (match-beginning 2))
  219.         (value-end (match-end 2)))
  220.     (goto-char value-start)
  221.     (while (re-search-forward "[^ \t]+" value-end 'no-error)
  222.       (setq property-list
  223.         (append
  224.          property-list
  225.          (list (buffer-substring-no-properties
  226.             (match-beginning 0) (match-end 0))))))
  227.     (setq address (car property-list)
  228.           property-list (cdr property-list)
  229.           remailer-name name)
  230.     (if (not
  231.          (or (member "mix" property-list)
  232.          (and (or (member "pgp" property-list)
  233.               (member "pgp." property-list))
  234.               (or (member "cpunk" property-list)
  235.               (member "eric" property-list)))))
  236.         (setq remailer nil)
  237.       (setq remailer
  238.         (mc-remailer-create
  239.          address        ; Address
  240.          (if (member "pgp." property-list)
  241.              name)        ; User ID
  242.          property-list
  243.          '(mc-generic-pre-encrypt-function) ; Pre-encrypt hooks
  244.          '(mc-generic-post-encrypt-function) ; Post-encrypt hooks
  245.          ))))
  246.       (if (not (null remailer))
  247.       (setq chains (cons (list remailer-name remailer) chains))))
  248.     (goto-char (point-min))
  249.     (if (re-search-forward "----------" nil t)
  250.     (while (re-search-forward "^\\([a-zA-Z0-9\\-]+\\) " nil t)
  251.       (setq remailer-name (buffer-substring-no-properties
  252.                    (match-beginning 1) (match-end 1)))
  253.       (if (assoc remailer-name chains)
  254.           (setq ranking (append ranking (list remailer-name))))))
  255.     (cons chains ranking)))
  256.  
  257. (defun mc-read-levien-file ()
  258.   "Read the Levien format file specified in `mc-levien-file-name'.
  259. Return an alist of length-1 chains, one for each remailer, named
  260. after the remailer.  Only include remailers supporting PGP
  261. encryption."
  262.   (save-excursion
  263.     (if (file-readable-p mc-levien-file-name)
  264.     (prog2
  265.         (find-file-read-only mc-levien-file-name)
  266.         (mc-parse-levien-buffer)
  267.       (bury-buffer)))))
  268.  
  269. (defun mc-reread-levien-file ()
  270.   "Read the Levien format file specified in `mc-levien-file-name'.
  271.  
  272. Place result in `mc-remailer-internal-chains' and `mc-remailer-internal-ranking'.
  273.  
  274. See the documentation for the variable `mc-levien-file-name' for
  275. a description of Levien file format."
  276.   (interactive)
  277.   (let ((parsed-levien-file (mc-read-levien-file)))
  278.     (setq mc-remailer-internal-chains (car parsed-levien-file)
  279.       mc-remailer-internal-ranking (cdr parsed-levien-file))))
  280.  
  281. ;;}}}
  282. ;;{{{ Arbitrary chain choice
  283.  
  284. (defun mc-remailer-choose-first (n &optional l)
  285.   (cond
  286.    ((= n 0) nil)
  287.    ((null l) (mc-remailer-choose-first n mc-remailer-internal-ranking))
  288.    (t (cons (car l) (mc-remailer-choose-first (1- n) (cdr l))))))
  289.  
  290. (defun mc-remailer-choose-chain (n)
  291.   (if (null mc-remailer-internal-ranking)
  292.       (error "No ranking information, cannot choose the %d best remailer%s"
  293.          n (if (> n 1) "s" "")))
  294.   (append (shuffle-vector (vconcat (mc-remailer-choose-first n)))
  295.       nil))
  296.  
  297. ;;}}}
  298. ;;{{{ Canonicalization function
  299.  
  300. (defun mc-remailer-canonicalize-elmt (elmt chains-alist)
  301.   (cond
  302.    ((mc-remailerp elmt) (list elmt))
  303.    ((stringp elmt)
  304.     (mc-remailer-canonicalize-chain (cdr (assoc elmt chains-alist))
  305.                     chains-alist))
  306.    ((integerp elmt)
  307.     (mc-remailer-canonicalize-chain (mc-remailer-choose-chain elmt)
  308.                     chains-alist))
  309.    (t (mc-remailer-canonicalize-chain (eval elmt) chains-alist))))
  310.  
  311. (defun mc-remailer-canonicalize-chain (chain &optional chains-alist)
  312.   ;; Canonicalize a remailer chain with respect to CHAINS-ALIST.
  313.   ;; That is, use CHAINS-ALIST to resolve strings.
  314.   ;; Here is where we implement the functionality described in
  315.   ;; the documentation for the variable `mc-remailer-user-chains'.
  316.   (if (null chains-alist)
  317.       (setq chains-alist (mc-remailer-make-chains-alist)))
  318.   (cond
  319.    ((null chain) nil)
  320.    ;; Handle case where chain is actually a string or a single
  321.    ;; remailer.
  322.    ((or (stringp chain) (mc-remailerp chain) (integerp chain))
  323.     (mc-remailer-canonicalize-elmt chain chains-alist))
  324.    (t
  325.     (let ((first (elt chain 0))
  326.       (rest (cdr (append chain nil))))
  327.       (append
  328.        (mc-remailer-canonicalize-elmt first chains-alist)
  329.        (mc-remailer-canonicalize-chain rest chains-alist))))))
  330.  
  331. ;;}}}
  332. ;;{{{ Auxiliaries for mail header munging
  333.  
  334. (defsubst mc-nuke-field (field &optional bounds)
  335.   ;; Delete all fields exactly matching regexp FIELD from header,
  336.   ;; bounded by BOUNDS.  Default is entire visible region of buffer.
  337.   (mc-get-fields field bounds t))
  338.  
  339. (defun mc-replace-field (field-name replacement header)
  340.   (save-excursion
  341.     (save-restriction
  342.       (if (not (string-match "^[ \t]" replacement))
  343.       (setq replacement (concat " " replacement)))
  344.       (if (not (string-match "\n$" replacement))
  345.       (setq replacement (concat replacement "\n")))
  346.       (let ((case-fold-search t)
  347.         (field-regexp (regexp-quote field-name)))
  348.     (narrow-to-region (car header) (cdr header))
  349.     (goto-char (point-min))
  350.     (re-search-forward
  351.      (concat "^" field-regexp ":" mc-field-body-regexp)
  352.      nil t)
  353.     (mc-nuke-field field-regexp header)
  354.     (insert field-name ":" replacement)))))
  355.  
  356. (defun mc-find-main-header (&optional ignored)
  357.   ;; Find the main header of the mail message; return as a pair of
  358.   ;; markers (START . END).
  359.   (save-excursion
  360.     (goto-char (point-min))
  361.     (re-search-forward
  362.      (concat "^" (regexp-quote mail-header-separator) "\n"))
  363.     (forward-line -1)
  364.     (cons (copy-marker (point-min)) (copy-marker (point)))))
  365.         
  366. (defun mc-find-colon-header (&optional insert)
  367.   ;; Find the header with a "::" immediately after the
  368.   ;; mail-header-separator.  Return region enclosing header.  Optional
  369.   ;; arg INSERT means insert the header if it does not exist already.
  370.   (save-excursion
  371.     (goto-char (point-min))
  372.     (re-search-forward
  373.      (concat "^" (regexp-quote mail-header-separator) "\n"))
  374.     (if (or (and (looking-at "::\n") (forward-line 1))
  375.         (and insert
  376.          (progn
  377.            (insert-before-markers "::\n\n")
  378.            (forward-line -1))))
  379.     (let ((start (point)))
  380.       (re-search-forward "^$" nil 'move)
  381.       (cons (copy-marker start) (copy-marker (point)))))))
  382.  
  383. (defun mc-find-hash-header (&optional insert)
  384.   (save-excursion
  385.     (goto-char (point-min))
  386.     (re-search-forward
  387.      (concat "^" (regexp-quote mail-header-separator) "\n"))
  388.     (if (or (and (looking-at "##\n") (forward-line 1))
  389.         (and (looking-at "::\n")
  390.          (re-search-forward "^\n" nil 'move)
  391.          (looking-at "##\n")
  392.          (forward-line 1))
  393.         (and insert
  394.          (progn
  395.            (insert-before-markers "##\n\n")
  396.            (forward-line -1))))
  397.     (let ((start (point)))
  398.       (re-search-forward "^$" nil 'move)
  399.       (cons (copy-marker start) (copy-marker (point)))))))
  400.  
  401.  
  402. (defsubst mc-replace-main-field (field replacement)
  403.   (mc-replace-field field replacement (mc-find-main-header t)))
  404.  
  405. (defsubst mc-replace-hash-field (field replacement)
  406.   (mc-replace-field field replacement (mc-find-hash-header t)))
  407.  
  408. (defsubst mc-replace-colon-field (field replacement)
  409.   (mc-replace-field field replacement (mc-find-colon-header t)))
  410.  
  411. (defun mc-recipient-is-remailerp ()
  412.   (let ((to (mc-get-fields "To" (mc-find-main-header))))
  413.     (and to
  414.      (string-match (regexp-quote mc-remailer-tag) (cdr (car to))))))
  415.  
  416. ;;}}}
  417. ;;{{{ Pre-encryption and post-encryption hook defaults
  418.  
  419. (defun mc-generic-post-encrypt-function (remailer)
  420.   (let ((main-header (mc-find-main-header))
  421.     (colon-header (mc-find-colon-header t)))
  422.     (mc-replace-field "Encrypted" "PGP" colon-header)
  423.     (mc-replace-field
  424.      "To"
  425.      (concat (mc-remailer-address remailer) " " mc-remailer-tag)
  426.      main-header)))
  427.  
  428. (defun mc-generic-pre-encrypt-function (remailer)
  429.   (let ((addr (mc-remailer-address remailer))
  430.     (props (mc-remailer-properties remailer))
  431.     (main-header (mc-find-main-header))
  432.     (colon-header (mc-find-colon-header t))
  433.     to to-field preserved-regexp preserved)
  434.  
  435.     (setq preserved-regexp
  436.       (mc-disjunction-regexp mc-remailer-preserved-headers))
  437.     (setq preserved (mc-get-fields preserved-regexp main-header t))
  438.     (if preserved (goto-char (cdr (mc-find-hash-header t))))
  439.     (mapcar (function
  440.          (lambda (c)
  441.            (insert (car c) ":"
  442.                (mc-eliminate-continuation-lines (cdr c)))))
  443.         preserved)
  444.  
  445.     (if (and (mc-find-hash-header) (not (member "hash" props)))
  446.     (error "Remailer %s does not support hashmarks" addr))
  447.  
  448.     (if (mc-get-fields "Newsgroups" main-header)
  449.     (cond ((not (member "post" props))
  450.            (error "Remailer %s does not support posting" addr))
  451.           ((not (member "hash" props))
  452.            (error "Remailer %s does not support hashmarks" addr))
  453.           (t (mc-rewrite-news-to-mail remailer)))
  454.       (and (featurep 'mailalias)
  455.        (not (featurep 'mail-abbrevs))
  456.        mail-aliases
  457.        (expand-mail-aliases (car main-header) (cdr main-header)))
  458.       (setq to (mc-strip-addresses
  459.         (mapcar 'cdr (mc-get-fields "To" main-header))))
  460.       (if (string-match "," to)
  461.       (error "Remailer %s does not support multiple recipients." addr))
  462.       (setq to-field
  463.         (if (mc-get-fields "From" colon-header)
  464.         "Send-To"
  465.           (cond
  466.            ((member "eric" props) "Anon-Send-To")
  467.            ((member "cpunk" props) "Request-Remailing-To")
  468.            (t (error "Remailer %s is not type-1" addr)))))
  469.       (mc-replace-field to-field to colon-header)
  470.       (mc-nuke-field "Reply-to" main-header))))
  471.     
  472. ;;}}}
  473. ;;{{{ Misc. random
  474.  
  475. (defun mc-disjunction-regexp (regexps)
  476.   ;; Take a list of regular expressions and return a single
  477.   ;; regular expression which matches anything that any of the
  478.   ;; original regexps match.
  479.   (concat "\\("
  480.       (mapconcat 'identity regexps "\\)\\|\\(")
  481.       "\\)"))
  482.  
  483. (defun mc-user-mail-address ()
  484.   "Figure out the user's Email address as best we can."
  485.   (mc-strip-address
  486.    (cond ((and (boundp 'gnus-user-from-line)
  487.            (stringp gnus-user-from-line))
  488.       gnus-user-from-line)
  489.      ((stringp mail-default-reply-to) mail-default-reply-to)
  490.      ((boundp 'user-mail-address) user-mail-address)
  491.      (t (concat (user-login-name) "@" (system-name))))))
  492.  
  493. (defun mc-eliminate-continuation-lines (string)
  494.   (while (string-match "\n[\t ]+" string)
  495.     (setq string (replace-match " " t nil string)))
  496.   string)
  497.  
  498. (defun mc-remailer-make-chains-alist ()
  499.   (if (null mc-remailer-internal-chains)
  500.       (mc-reread-levien-file))
  501.   (append mc-remailer-internal-chains mc-remailer-user-chains))
  502.  
  503. ;;;###autoload
  504. (defun mc-remailer-insert-pseudonym ()
  505.   "Insert pseudonym as a From field in the hash-mark header.
  506.  
  507. See the documentation for the variable `mc-remailer-pseudonyms' for
  508. more information."
  509.   (interactive)
  510.   (let ((completion-ignore-case t)
  511.     pseudonym)
  512.     (setq pseudonym
  513.       (cond ((null mc-remailer-pseudonyms)
  514.          (read-from-minibuffer "Pseudonym: "))
  515.         (t
  516.          (completing-read "Pseudonym: "
  517.                   (mapcar 'list mc-remailer-pseudonyms)))))
  518.     (if (not (string-match "\\S +@\\S +" pseudonym))
  519.     (setq pseudonym (concat pseudonym " <x@x.x>")))
  520.     (mc-replace-colon-field "From" pseudonym)))
  521.  
  522. ;;}}}
  523. ;;{{{ Mixmaster support
  524. (defvar mc-mixmaster-path nil
  525.   "*Path to the Mixmaster binary.  If defined, Mixmaster chains will
  526. be passed to this program for rewriting.")
  527.  
  528. (defvar mc-mixmaster-list-path nil
  529.   "*Path to the Mixmaster type2.list file.")
  530.  
  531. (defun mc-demix (&rest chain)
  532.   "Use arguments as a remailer-list and return a new list with the
  533. \"mix\" property removed from all the elements."
  534.   (mapcar (function (lambda (r) (mc-remailer-remove-property r "mix")))
  535.       (mc-remailer-canonicalize-chain chain)))
  536.  
  537. (defun mc-mixmaster-process (beg end recipients preserved mix-chain)
  538.   ;; Run a region through Mixmaster.
  539.   (let (ret)
  540.     (if (not (markerp end))
  541.     (setq end (copy-marker end)))
  542.     (goto-char beg)
  543.     (mapcar (function (lambda (x) (insert x ?\n))) recipients)
  544.     (insert ?\n)
  545.     (mapcar (function (lambda (x) (insert x))) preserved)
  546.     (insert ?\n)
  547.     (setq mix-chain (mapcar (function (lambda (x) (format "%d" x))) mix-chain))
  548.     ;; Handle case of empty message
  549.     (if (< end (point)) (setq end (point)))
  550.     (setq ret
  551.       (apply 'call-process-region beg end mc-mixmaster-path t t nil
  552.          "-f" "-o" "stdout" "-l" mix-chain))
  553.     (if (not (eq ret 0)) (error "Mixmaster barfed."))
  554.     (goto-char beg)
  555.     (re-search-forward "^::$")
  556.     (delete-region beg (match-beginning 0))))
  557.  
  558. (defun mc-mixmaster-build-alist (&optional n)
  559.   ;; Construct an alist mapping Mixmaster Email addresses to integers.
  560.   ;; FIXME; this is terrible
  561.   (let (buf)
  562.     (save-excursion
  563.       (unwind-protect
  564.       (progn
  565.         (setq n (or n 1))
  566.         (setq buf (find-file-noselect mc-mixmaster-list-path))
  567.         (set-buffer buf)
  568.         (if (re-search-forward "^[^ \t]+[ \t]+\\([^ \t]+\\)" nil t)
  569.         (cons (cons (buffer-substring-no-properties
  570.                  (match-beginning 1) (match-end 1))
  571.                 n)
  572.             (mc-mixmaster-build-alist (+ n 1)))))
  573.     (if buf (kill-buffer buf))))))
  574.  
  575. (defvar mc-mixmaster-alist nil)
  576.  
  577. (defsubst mc-mixmaster-alist ()
  578.   (or mc-mixmaster-alist
  579.       (setq mc-mixmaster-alist (mc-mixmaster-build-alist))))
  580.  
  581. (defun mc-mixmaster-translate-chain (chain)
  582.   ;; Take a chain of Mixmaster remailers and convert it to the list
  583.   ;; of integers which represents them.
  584.   (if (or (null chain)
  585.       (not (member "mix" (mc-remailer-properties (car chain)))))
  586.       nil
  587.     (cons (cdr (assoc (mc-strip-address (mc-remailer-address (car chain)))
  588.               (mc-mixmaster-alist)))
  589.       (mc-mixmaster-translate-chain (cdr chain)))))
  590.  
  591. (defun mc-mixmaster-skip (chain)
  592.   ;; Return the largest possible suffix of CHAIN whose first element
  593.   ;; is not a Mixmaster.
  594.   (cond ((null chain) nil)
  595.     ((not (member "mix" (mc-remailer-properties (car chain))))
  596.      chain)
  597.     (t (mc-mixmaster-skip (cdr chain)))))
  598.  
  599. (defun mc-rewrite-for-mixmaster (chain &optional pause)
  600.   ;; Rewrite the current mail buffer for a chain of Mixmasters.
  601.   (let ((mix-chain (mc-mixmaster-translate-chain chain))
  602.     (main-header (mc-find-main-header))
  603.     (colon-header (mc-find-colon-header))
  604.     (hash-header (mc-find-hash-header))
  605.     recipients preserved newsgroups first last rest preserved-regexp)
  606.  
  607.     ;; Figure out FIRST and LAST. FIRST is the first Mixmaster in the
  608.     ;; chain.  LAST is the last.
  609.     (setq first (car chain)
  610.       rest chain)
  611.     (while (and rest (member "mix" (mc-remailer-properties (car rest))))
  612.       (setq last (car rest)
  613.         rest (cdr rest)))
  614.     
  615.     ;; If recipient is not a remailer, deal with hashmark and colon
  616.     ;; headers and get rid of them.
  617.     (if (mc-recipient-is-remailerp)
  618.     nil
  619.       (if hash-header
  620.       (progn
  621.         (setq preserved (mc-get-fields nil hash-header))
  622.         (goto-char (car hash-header))
  623.         (forward-line -1)
  624.         (delete-region (point) (+ (cdr hash-header) 1))))
  625.       ;; Preserve pseduonym line...
  626.       (if colon-header
  627.       (progn
  628.         (setq preserved
  629.           (append (mc-get-fields "From" colon-header) preserved))
  630.         (goto-char (car colon-header))
  631.         (forward-line -1)
  632.         (delete-region (point) (+ (cdr colon-header) 1)))))
  633.     
  634.     ;; Expand aliases and get recipients.
  635.     (and (featurep 'mailalias)
  636.      (not (featurep 'mail-abbrevs))
  637.      mail-aliases
  638.      (expand-mail-aliases (car main-header) (cdr main-header)))
  639.     (setq recipients
  640.       (mc-cleanup-recipient-headers
  641.        (mapconcat 'cdr (mc-get-fields "To" main-header t) ", ")))
  642.     (setq newsgroups (mc-get-fields "Newsgroups" nil t))
  643.     ;; Mixmaster does not support posting...
  644. ;;;    (if (and newsgroups
  645. ;;;         (not (member "post" (mc-remailer-properties last))))
  646.     (if newsgroups
  647.     (error "Remailer %s does not support posting"
  648.            (mc-remailer-address last)))
  649.     (setq
  650.      recipients
  651.      (append (mapcar
  652.           (function (lambda (c) (concat "Post:" (cdr c)))) newsgroups)
  653.          recipients))
  654.  
  655.     (setq
  656.      preserved-regexp
  657.      (mc-disjunction-regexp (cons "Subject" mc-remailer-preserved-headers)))
  658.  
  659.     (setq preserved
  660.       (append (mc-get-fields preserved-regexp main-header t) preserved))
  661.  
  662.     ;; Convert preserved header alist to simple list of strings
  663.     (setq preserved
  664.       (mapcar
  665.        (function
  666.         (lambda (c)
  667.           (concat (car c) ":"
  668.               (mc-eliminate-continuation-lines (cdr c)))))
  669.        preserved))
  670.  
  671.     ;; Do the conversion
  672.     (goto-char (cdr main-header))
  673.     (forward-line 1)
  674.     (mc-mixmaster-process (point) (point-max) recipients preserved
  675.               mix-chain)
  676.  
  677.     (mc-replace-field "To"
  678.               (concat
  679.                (mc-remailer-address first) " " mc-remailer-tag)
  680.               main-header)))
  681.  
  682. ;;}}}
  683. ;;{{{ High level message rewriting
  684.  
  685. (defun mc-rewrite-news-to-mail (remailer)
  686.   (let ((main-header (mc-find-main-header))
  687.     newsgroups)
  688.     (setq newsgroups (mc-get-fields "Newsgroups" main-header t))
  689.     (mc-replace-colon-field "Post-To" (cdr (car newsgroups)))
  690.     (mail-mode)))
  691.  
  692. (defun mc-rewrite-for-remailer (remailer &optional pause)
  693.   ;; Rewrite the current mail buffer for a single remailer.  This
  694.   ;; includes running the pre-encryption hooks, modifying the To:
  695.   ;; field, encrypting with the remailer's public key, and running the
  696.   ;; post-encryption hooks.
  697.   (let ((addr (mc-remailer-address remailer))
  698.     (main-header (mc-find-main-header)))
  699.     ;; If recipient is already a remailer, make sure the "::" and "##"
  700.     ;; headers get to it
  701.     (if (mc-recipient-is-remailerp)
  702.     (progn
  703.       (goto-char (cdr main-header))
  704.       (forward-line 1)
  705.       (insert "::\n\n")))
  706.  
  707.     (mapcar
  708.      (function (lambda (hook) (funcall hook remailer)))
  709.      (mc-remailer-pre-encrypt-hooks remailer))
  710.  
  711.     ;; Move "Subject" lines down.
  712.     (goto-char (car (mc-find-colon-header t)))
  713.     (mapcar
  714.      (function (lambda (f) (insert (car f) ":" (cdr f))))
  715.      (mc-get-fields "Subject" main-header t))
  716.  
  717.     (if pause
  718.     (let ((cursor-in-echo-area t))
  719.       (message "SPC to encrypt for %s : " addr)
  720.       (read-char-exclusive)))
  721.     (setq main-header (mc-find-main-header))
  722.     (goto-char (cdr main-header))
  723.     (forward-line 1)
  724.     (if (let ((mc-pgp-always-sign 'never)
  725.           (mc-encrypt-for-me nil))
  726.       (mc-encrypt-message (mc-remailer-userid remailer) nil (point)))
  727.     (progn
  728.       (mapcar
  729.        (function (lambda (hook) (funcall hook remailer)))
  730.        (mc-remailer-post-encrypt-hooks remailer))
  731.       (mc-nuke-field "Comment")
  732.       (mc-nuke-field "From"))
  733.       (error "Unable to encrypt message to %s"
  734.          (mc-remailer-userid remailer)))))
  735.  
  736. (defun mc-rewrite-for-chain (chain &optional pause)
  737.   ;; Rewrite the current buffer for a chain of remailers.
  738.   ;; CHAIN must be in canonical form.
  739.   (let (rest)
  740.     (if mc-mixmaster-path
  741.     (setq rest (mc-mixmaster-skip chain))
  742.       (setq rest chain))
  743.     (if (null chain) nil
  744.       (mc-rewrite-for-chain
  745.        (if (eq rest chain) (cdr rest) rest) pause)
  746.       (if (eq rest chain)
  747.       (mc-rewrite-for-remailer (car chain) pause)
  748.     (mc-rewrite-for-mixmaster chain pause)))))
  749.  
  750. (defun mc-unparse-chain (chain)
  751.   ;; Unparse CHAIN into a string suitable for printing.
  752.   (if (null chain)
  753.       nil
  754.     (concat (mc-remailer-address (car chain)) "\n"
  755.         (mc-unparse-chain (cdr chain)))))
  756.  
  757. (defun mc-disallow-field (field &optional header)
  758.   (let ((case-fold-search t))
  759.     (if (null header)
  760.     (setq header (mc-find-main-header)))
  761.     (goto-char (car header))
  762.     (if (re-search-forward (concat "^" (regexp-quote field) ":")
  763.               (cdr header) t)
  764.     
  765.     (progn
  766.       (goto-char (match-beginning 0))
  767.       (error "Cannot use a %s field." field)))))
  768.  
  769. ;;;###autoload
  770. (defun mc-remailer-encrypt-for-chain (&optional pause)
  771.   "Encrypt message for a remailer chain, prompting for chain to use.
  772.  
  773. With \\[universal-argument], pause before each encryption."
  774.   (interactive "P")
  775.   (let ((chains (mc-remailer-make-chains-alist))
  776.     (buffer (get-buffer-create mc-buffer-name))
  777.     chain-name chain)
  778.     (mc-disallow-field "CC")
  779.     (mc-disallow-field "FCC")
  780.     (mc-disallow-field "BCC")
  781.     (setq chain-name
  782.       (completing-read
  783.        "Choose a remailer or chain: " chains nil 'strict-match))
  784.     (setq chain
  785.       (mc-remailer-canonicalize-chain
  786.        (cdr (assoc chain-name chains))
  787.        chains))
  788.     (mc-rewrite-for-chain chain pause)
  789.     (if chain
  790.     (save-excursion
  791.       (set-buffer buffer)
  792.       (erase-buffer)
  793.       (insert "Rewritten for chain `" chain-name "':\n\n"
  794.           (mc-unparse-chain chain))
  795.       (message "Done.  See %s buffer for details." mc-buffer-name)))))
  796.  
  797. ;;}}}
  798. ;;{{{ Response block generation
  799.  
  800. ;;;###autoload
  801. (defun mc-remailer-insert-response-block (&optional arg)
  802.   "Insert response block at point, prompting for chain to use.
  803.  
  804. With \\[universal-argument], enter a recursive edit of the innermost
  805. layer of the block before encrypting it."
  806.   (interactive "p")
  807.   (let (buf main-header to addr block lines)
  808.     (save-excursion
  809.       (setq buf
  810.         (mc-remailer-make-response-block (if (> arg 1) t)))
  811.       (set-buffer buf)
  812.       (setq main-header (mc-find-main-header))
  813.       (setq to (cdr (car (mc-get-fields "To" main-header))))
  814.       (setq addr (concat "<" (mc-strip-address to) ">"))
  815.       (goto-char (cdr main-header))
  816.       (forward-line 1)
  817.       (setq block (buffer-substring-no-properties
  818.            (point) (point-max))
  819.         lines (count-lines (point) (point-max)))
  820.       (kill-buffer buf))
  821.     (let ((opoint (point)))
  822.       (insert (funcall mc-remailer-user-response-block
  823.                addr lines block))
  824.       (goto-char opoint))
  825.     (mc-nuke-field "Reply-to" (mc-find-main-header))
  826.     (mc-replace-hash-field "Reply-to" addr)))
  827.  
  828. (defun mc-remailer-make-response-block (&optional recurse)
  829.   ;; Return a buffer which contains a response block
  830.   ;; for the user, and a To: header for the remailer to use.
  831.   (let ((buf (generate-new-buffer " *Remailer Response Block*"))
  832.     (original-buf (current-buffer))
  833.     (mc-mixmaster-path nil)
  834.     all-headers included-regexp included)
  835.     (setq all-headers (mc-find-main-header))
  836.     (setcdr all-headers
  837.         (max
  838.          (cdr all-headers)
  839.          (or (cdr-safe (mc-find-colon-header)) 0)
  840.          (or (cdr-safe (mc-find-hash-header)) 0)))
  841.     (save-excursion
  842.       (setq
  843.        included-regexp
  844.        (mc-disjunction-regexp mc-response-block-included-headers))
  845.       (setq included (mc-get-fields included-regexp all-headers))
  846.       (set-buffer buf)
  847.       (insert "To: " (mc-user-mail-address) "\n" mail-header-separator "\n")
  848.       (insert ";; Response block created " (current-time-string) "\n")
  849.       (mapcar (function (lambda (c) (insert "; " (car c) ":" (cdr c))))
  850.           included)
  851.       (if recurse
  852.       (progn
  853.         (switch-to-buffer buf)
  854.         (message "Editing response block ; %s when done."
  855.              (substitute-command-keys "\\[exit-recursive-edit]"))
  856.         (recursive-edit)))
  857.       (set-buffer buf)
  858.       (mc-remailer-encrypt-for-chain)
  859.       (switch-to-buffer original-buf))
  860.     buf))
  861.  
  862. ;;}}}
  863.